[Sbcl-commits] CVS: sbcl/src/compiler array-tran.lisp, 1.89, 1.90 ir1opt.lisp, 1.135, 1.136 ir1util.lisp, 1.125, 1.126 locall.lisp, 1.95, 1.96

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv22761/src/compiler

Modified Files:
	array-tran.lisp ir1opt.lisp ir1util.lisp locall.lisp 
Log Message:
1.0.28.51: better MAKE-ARRAY transforms

 * Add a source transform for MAKE-ARRAY that declaims LIST and VECTOR
   as NOTINLINE, so the the MAKE-ARRAY deftransforms are able to pick
   them apart (for DIMENSIONS and :INITIAL-CONTENTS.)

 * INITIALIZE-VECTOR is a new magic function with a IR2-CONVERT
   transform. It's purpose is to allow open coding :INITIAL-CONTENTS
   initialization without inhibiting stack allocation.

 * Turns out that making stack allocation decisions during locall
   analysis is not enough since optimization iterates: if a transform
   occurs and introduces new LVARs that would be good for DX after
   the locall analysis has run for the combination, the new LVARs
   will not get their share of stacky goodness. Therefore, after
   a transform propagate DX information to the new functional
   explicitly (see MAYBE-PROPAGATE-DYNAMIC-EXTENT.)

 * The new logic is in TRANSFORM-MAKE-ARRAY-VECTOR, which handles
   all the cases of vector allocation with a known element type:

   ** :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and (BACKQ-LIST ...)
      are picked apart when the length matches the vector length,
      and their arguments are spliced into the call.

      Constant :INITIAL-CONTENTS is picked apart as well.

      Initialization is done using INITIALIZE-VECTOR.

   ** Otherwise :INITIAL-CONTENTS is splatted in place using
      REPLACE after we have checked that the length matches.

   ** :INITIAL-ELEMENT not EQL to the default element uses
      FILL.

   ** Otherwise the default initialization is fine.

   Some additional hair here, since MAYBE-PROPAGATE-DYNAMIC-EXTENT
   cannot deal with OPTIONAL-DISPATCH functionals. So to ensure we get
   full benefit of it, make sure the lambdas we transform to have only
   required arguments -- courtesy of new ELIMINATE-KEYWORD-ARGUMENT
   utility. (Note: it might be worth it to do something like this for
   many cases automatically, to reduce the number of lambdas the
   compiler generates. For inline lambdas we could do the whole &key
   handling _before_ the lambda is converted...)

 * Identify the case of (LIST N) as dimensions as being a vector,
   and delegate to TRANSFORM-MAKE-ARRAY-VECTOR.

 * More efficient allocation of simple multidimensional arrays in
   the presence of :INITIAL-CONTENTS (still slow, though) and
   :INITIAL-ELEMENT (not bad.)

 * Fix the source transform for VECTOR so that it too can stack
   allocate.

 * Updates tests and docs.


Index: array-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v
retrieving revision 1.89
retrieving revision 1.90
diff -u -d -r1.89 -r1.90
--- array-tran.lisp	15 May 2009 21:11:45 -0000	1.89
+++ array-tran.lisp	16 May 2009 12:23:13 -0000	1.90
@@ -217,19 +217,9 @@
 
 ;;;; constructors
 
-;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
-;;; elements.
+;;; Convert VECTOR into a MAKE-ARRAY.
 (define-source-transform vector (&rest elements)
-  (let ((len (length elements))
-        (n -1))
-    (once-only ((n-vec `(make-array ,len)))
-      `(progn
-         ,@(mapcar (lambda (el)
-                     (once-only ((n-val el))
-                       `(locally (declare (optimize (safety 0)))
-                          (setf (svref ,n-vec ,(incf n)) ,n-val))))
-                   elements)
-         ,n-vec))))
+  `(make-array ,(length elements) :initial-contents (list ,@elements)))
 
 ;;; Just convert it into a MAKE-ARRAY.
 (deftransform make-string ((length &key
@@ -241,6 +231,240 @@
                        ,@(when initial-element
                            '(:initial-element initial-element)))))
 
+;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments,
+;;; so that we can pick them apart.
+(define-source-transform make-array (&whole form &rest args)
+  (declare (ignore args))
+  (if (and (fun-lexically-notinline-p 'list)
+           (fun-lexically-notinline-p 'vector))
+      (values nil t)
+      `(locally (declare (notinline list vector))
+         ,form)))
+
+;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
+;;; call which creates a vector with a known element type -- and tries
+;;; to do a good job with all the different ways it can happen.
+(defun transform-make-array-vector (length element-type initial-element
+                                    initial-contents call)
+  (aver (or (not element-type) (constant-lvar-p element-type)))
+  (let* ((c-length (when (constant-lvar-p length)
+                     (lvar-value length)))
+         (elt-spec (if element-type
+                       (lvar-value element-type)
+                       t))
+         (elt-ctype (ir1-transform-specifier-type elt-spec))
+         (saetp (if (unknown-type-p elt-ctype)
+                    (give-up-ir1-transform "~S is an unknown type: ~S"
+                                           :element-type elt-spec)
+                    (find-saetp-by-ctype elt-ctype)))
+         (default-initial-element (sb!vm:saetp-initial-element-default saetp))
+         (n-bits (sb!vm:saetp-n-bits saetp))
+         (typecode (sb!vm:saetp-typecode saetp))
+         (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
+         (n-words-form
+          (if c-length
+              (ceiling (* (+ c-length n-pad-elements) n-bits)
+                       sb!vm:n-word-bits)
+              (let ((padded-length-form (if (zerop n-pad-elements)
+                                            'length
+                                            `(+ length ,n-pad-elements))))
+                (cond
+                  ((= n-bits 0) 0)
+                  ((>= n-bits sb!vm:n-word-bits)
+                   `(* ,padded-length-form
+                       ;; i.e., not RATIO
+                       ,(the fixnum (/ n-bits sb!vm:n-word-bits))))
+                  (t
+                   (let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits)))
+                     (declare (type index n-elements-per-word)) ; i.e., not RATIO
+                     `(ceiling ,padded-length-form ,n-elements-per-word)))))))
+         (result-spec
+          `(simple-array ,(sb!vm:saetp-specifier saetp) (,(or c-length '*))))
+         (alloc-form
+          `(truly-the ,result-spec
+                      (allocate-vector ,typecode (the index length) ,n-words-form))))
+    (cond ((and initial-element initial-contents)
+           (abort-ir1-transform "Both ~S and ~S specified."
+                                :initial-contents :initial-element))
+          ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
+          ;; constant LENGTH.
+          ((and initial-contents c-length
+                (lvar-matches initial-contents
+                              :fun-names '(list vector sb!impl::backq-list)
+                              :arg-count c-length))
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)
+                                       (:initial-contents initial-contents))))
+                 (elt-vars (make-gensym-list c-length))
+                 (lambda-list '(length)))
+             (splice-fun-args initial-contents :any c-length)
+             (dolist (p parameters)
+               (setf lambda-list
+                     (append lambda-list
+                             (if (eq p 'initial-contents)
+                                 elt-vars
+                                 (list p)))))
+             `(lambda ,lambda-list
+                (declare (type ,elt-spec ,@elt-vars)
+                         (ignorable ,@lambda-list))
+                (truly-the ,result-spec
+                 (initialize-vector ,alloc-form ,@elt-vars)))))
+          ;; constant :INITIAL-CONTENTS and LENGTH
+          ((and initial-contents c-length (constant-lvar-p initial-contents))
+           (let ((contents (lvar-value initial-contents)))
+             (unless (= c-length (length contents))
+               (abort-ir1-transform "~S has ~S elements, vector length is ~S."
+                                    :initial-contents (length contents) c-length))
+             (let ((parameters (eliminate-keyword-args
+                                call 1 '((:element-type element-type)
+                                         (:initial-contents initial-contents)))))
+               `(lambda (length ,@parameters)
+                  (declare (ignorable ,@parameters))
+                  (truly-the ,result-spec
+                   (initialize-vector ,alloc-form
+                                      ,@(map 'list (lambda (elt)
+                                                     `(the ,elt-spec ,elt))
+                                             contents)))))))
+          ;; any other :INITIAL-CONTENTS
+          (initial-contents
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)
+                                       (:initial-contents initial-contents)))))
+             `(lambda (length ,@parameters)
+                (declare (ignorable ,@parameters))
+                (unless (= length (length initial-contents))
+                  (error "~S has ~S elements, vector length is ~S."
+                         :initial-contents (length initial-contents) length))
+                (truly-the ,result-spec
+                           (replace ,alloc-form initial-contents)))))
+          ;; :INITIAL-ELEMENT, not EQL to the default
+          ((and initial-element
+                (or (not (constant-lvar-p initial-element))
+                    (not (eql default-initial-element (lvar-value initial-element)))))
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)
+                                       (:initial-element initial-element)))))
+             `(lambda (length ,@parameters)
+                (declare (ignorable ,@parameters))
+                (truly-the ,result-spec
+                           (fill ,alloc-form (the ,elt-spec initial-element))))))
+          ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
+          ;; default
+          (t
+           #-sb-xc-host
+           (unless (ctypep default-initial-element elt-ctype)
+             ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
+             ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
+             ;; INITIAL-ELEMENT is not supplied, the consequences of later
+             ;; reading an uninitialized element of new-array are undefined,"
+             ;; so this could be legal code as long as the user plans to
+             ;; write before he reads, and if he doesn't we're free to do
+             ;; anything we like. But in case the user doesn't know to write
+             ;; elements before he reads elements (or to read manuals before
+             ;; he writes code:-), we'll signal a STYLE-WARNING in case he
+             ;; didn't realize this.
+             (if initial-element
+                 (compiler-warn "~S ~S is not a ~S"
+                                :initial-element default-initial-element
+                                elt-spec)
+                 (compiler-style-warn "The default initial element ~S is not a ~S."
+                                      default-initial-element
+                                      elt-spec)))
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)))))
+             `(lambda (length ,@parameters)
+                (declare (ignorable ,@parameters))
+                ,alloc-form))))))
+
+(deftransform make-array ((dims &key
+                                element-type initial-element initial-contents)
+                          (integer &key
+                                   (:element-type (constant-arg *))
+                                   (:initial-element *)
+                                   (:initial-contents *))
+                          *
+                          :node call)
+  (transform-make-array-vector dims
+                               element-type
+                               initial-element
+                               initial-contents
+                               call))
+
+;;; The list type restriction does not ensure that the result will be a
+;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
+;;; and displaced-to keywords ensures that it will be simple.
+;;;
+;;; FIXME: should we generalize this transform to non-simple (though
+;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
+;;; deal with those? Maybe when the DEFTRANSFORM
+;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
+;;; CSR, 2002-07-01
+(deftransform make-array ((dims &key
+                                element-type initial-element initial-contents)
+                          (list &key
+                                (:element-type (constant-arg *))
+                                (:initial-element *)
+                                (:initial-contents *))
+                          *
+                          :node call)
+  (block make-array
+    (when (lvar-matches dims :fun-names '(list) :arg-count 1)
+      (let ((length (car (splice-fun-args dims :any 1))))
+        (return-from make-array
+          (transform-make-array-vector length
+                                       element-type
+                                       initial-element
+                                       initial-contents
+                                       call))))
+    (unless (constant-lvar-p dims)
+      (give-up-ir1-transform
+       "The dimension list is not constant; cannot open code array creation."))
+    (let ((dims (lvar-value dims)))
+      (unless (every #'integerp dims)
+        (give-up-ir1-transform
+         "The dimension list contains something other than an integer: ~S"
+         dims))
+      (if (= (length dims) 1)
+          `(make-array ',(car dims)
+                       ,@(when element-type
+                               '(:element-type element-type))
+                       ,@(when initial-element
+                               '(:initial-element initial-element))
+                       ,@(when initial-contents
+                               '(:initial-contents initial-contents)))
+          (let* ((total-size (reduce #'* dims))
+                 (rank (length dims))
+                 (spec `(simple-array
+                         ,(cond ((null element-type) t)
+                                ((and (constant-lvar-p element-type)
+                                      (ir1-transform-specifier-type
+                                       (lvar-value element-type)))
+                                 (sb!xc:upgraded-array-element-type
+                                  (lvar-value element-type)))
+                                (t '*))
+                         ,(make-list rank :initial-element '*))))
+            `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))
+                   (data (make-array ,total-size
+                                     ,@(when element-type
+                                             '(:element-type element-type))
+                                     ,@(when initial-element
+                                             '(:initial-element initial-element)))))
+               ,@(when initial-contents
+                       ;; FIXME: This is could be open coded at least a bit too
+                       `((sb!impl::fill-data-vector data ',dims initial-contents)))
+               (setf (%array-fill-pointer header) ,total-size)
+               (setf (%array-fill-pointer-p header) nil)
+               (setf (%array-available-elements header) ,total-size)
+               (setf (%array-data-vector header) data)
+               (setf (%array-displaced-p header) nil)
+               (setf (%array-displaced-from header) nil)
+               ,@(let ((axis -1))
+                      (mapcar (lambda (dim)
+                                `(setf (%array-dimension header ,(incf axis))
+                                       ,dim))
+                              dims))
+               (truly-the ,spec header)))))))
+
 (deftransform make-array ((dims &key initial-element element-type
                                      adjustable fill-pointer)
                           (t &rest *))
@@ -299,128 +523,6 @@
                  (%data-vector-and-index array 0)
                (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
              array)))))
-
-;;; The integer type restriction on the length ensures that it will be
-;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
-;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
-;;; :INITIAL-ELEMENT relies on another transform to deal with that
-;;; kind of initialization efficiently.
-(deftransform make-array ((length &key element-type)
-                          (integer &rest *))
-  (let* ((eltype (cond ((not element-type) t)
-                       ((not (constant-lvar-p element-type))
-                        (give-up-ir1-transform
-                         "ELEMENT-TYPE is not constant."))
-                       (t
-                        (lvar-value element-type))))
-         (len (if (constant-lvar-p length)
-                  (lvar-value length)
-                  '*))
-         (eltype-type (ir1-transform-specifier-type eltype))
-         (result-type-spec
-          `(simple-array
-            ,(if (unknown-type-p eltype-type)
-                 (give-up-ir1-transform
-                  "ELEMENT-TYPE is an unknown type: ~S" eltype)
-                 (sb!xc:upgraded-array-element-type eltype))
-            (,len)))
-         (saetp (find-if (lambda (saetp)
-                           (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
-                         sb!vm:*specialized-array-element-type-properties*)))
-    (unless saetp
-      (give-up-ir1-transform
-       "cannot open-code creation of ~S" result-type-spec))
-    #-sb-xc-host
-    (unless (ctypep (sb!vm:saetp-initial-element-default saetp) eltype-type)
-      ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
-      ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
-      ;; INITIAL-ELEMENT is not supplied, the consequences of later
-      ;; reading an uninitialized element of new-array are undefined,"
-      ;; so this could be legal code as long as the user plans to
-      ;; write before he reads, and if he doesn't we're free to do
-      ;; anything we like. But in case the user doesn't know to write
-      ;; elements before he reads elements (or to read manuals before
-      ;; he writes code:-), we'll signal a STYLE-WARNING in case he
-      ;; didn't realize this.
-      (compiler-style-warn "The default initial element ~S is not a ~S."
-                           (sb!vm:saetp-initial-element-default saetp)
-                           eltype))
-    (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp))
-           (typecode (sb!vm:saetp-typecode saetp))
-           (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
-           (padded-length-form (if (zerop n-pad-elements)
-                                   'length
-                                   `(+ length ,n-pad-elements)))
-           (n-words-form
-            (cond
-              ((= n-bits-per-element 0) 0)
-              ((>= n-bits-per-element sb!vm:n-word-bits)
-               `(* ,padded-length-form
-                 (the fixnum ; i.e., not RATIO
-                   ,(/ n-bits-per-element sb!vm:n-word-bits))))
-              (t
-               (let ((n-elements-per-word (/ sb!vm:n-word-bits
-                                             n-bits-per-element)))
-                 (declare (type index n-elements-per-word)) ; i.e., not RATIO
-                 `(ceiling ,padded-length-form ,n-elements-per-word))))))
-      (values
-       `(truly-the ,result-type-spec
-         (allocate-vector ,typecode length ,n-words-form))
-       '((declare (type index length)))))))
-
-;;; The list type restriction does not ensure that the result will be a
-;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
-;;; and displaced-to keywords ensures that it will be simple.
-;;;
-;;; FIXME: should we generalize this transform to non-simple (though
-;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
-;;; deal with those? Maybe when the DEFTRANSFORM
-;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
-;;; CSR, 2002-07-01
-(deftransform make-array ((dims &key element-type)
-                          (list &rest *))
-  (unless (or (null element-type) (constant-lvar-p element-type))
-    (give-up-ir1-transform
-     "The element-type is not constant; cannot open code array creation."))
-  (unless (constant-lvar-p dims)
-    (give-up-ir1-transform
-     "The dimension list is not constant; cannot open code array creation."))
-  (let ((dims (lvar-value dims)))
-    (unless (every #'integerp dims)
-      (give-up-ir1-transform
-       "The dimension list contains something other than an integer: ~S"
-       dims))
-    (if (= (length dims) 1)
-        `(make-array ',(car dims)
-                     ,@(when element-type
-                         '(:element-type element-type)))
-        (let* ((total-size (reduce #'* dims))
-               (rank (length dims))
-               (spec `(simple-array
-                       ,(cond ((null element-type) t)
-                              ((and (constant-lvar-p element-type)
-                                    (ir1-transform-specifier-type
-                                     (lvar-value element-type)))
-                               (sb!xc:upgraded-array-element-type
-                                (lvar-value element-type)))
-                              (t '*))
-                           ,(make-list rank :initial-element '*))))
-          `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
-             (setf (%array-fill-pointer header) ,total-size)
-             (setf (%array-fill-pointer-p header) nil)
-             (setf (%array-available-elements header) ,total-size)
-             (setf (%array-data-vector header)
-                   (make-array ,total-size
-                               ,@(when element-type
-                                   '(:element-type element-type))))
-             (setf (%array-displaced-p header) nil)
-             (setf (%array-displaced-from header) nil)
-             ,@(let ((axis -1))
-                 (mapcar (lambda (dim)
-                           `(setf (%array-dimension header ,(incf axis))
-                                  ,dim))
-                         dims))
-             (truly-the ,spec header))))))
 
 ;;;; miscellaneous properties of arrays
 

Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.135
retrieving revision 1.136
diff -u -d -r1.135 -r1.136
--- ir1opt.lisp	1 May 2009 10:35:43 -0000	1.135
+++ ir1opt.lisp	16 May 2009 12:23:14 -0000	1.136
@@ -1289,6 +1289,7 @@
             (ref (lvar-use (combination-fun call))))
         (change-ref-leaf ref new-fun)
         (setf (combination-kind call) :full)
+        (maybe-propagate-dynamic-extent call new-fun)
         (locall-analyze-component *current-component*))))
   (values))
 

Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.125
retrieving revision 1.126
diff -u -d -r1.125 -r1.126
--- ir1util.lisp	16 May 2009 11:24:31 -0000	1.125
+++ ir1util.lisp	16 May 2009 12:23:14 -0000	1.126
@@ -1554,9 +1554,9 @@
 ;;; arguments.
 (defun splice-fun-args (lvar fun num-args)
   #!+sb-doc
-  "If LVAR is a call to FUN with NUM-ARGS args, change those arguments
-   to feed directly to the LVAR-DEST of LVAR, which must be a
-   combination."
+  "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
+directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
+is :ANY, the function name is not checked."
   (declare (type lvar lvar)
            (type symbol fun)
            (type index num-args))
@@ -1566,7 +1566,8 @@
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))
-      (unless (eq (lvar-fun-name inside-fun) fun)
+      (unless (or (eq fun :any)
+                  (eq (lvar-fun-name inside-fun) fun))
         (give-up-ir1-transform))
       (let ((inside-args (combination-args inside)))
         (unless (= (length inside-args) num-args)
@@ -1587,7 +1588,40 @@
                 (combination-kind inside) :known)
           (setf (node-derived-type inside) *wild-type*)
           (flush-dest lvar)
-          (values))))))
+          inside-args)))))
+
+;;; Eliminate keyword arguments from the call (leaving the
+;;; parameters in place.
+;;;
+;;;    (FOO ... :BAR X :QUUX Y)
+;;; becomes
+;;;    (FOO ... X Y)
+;;;
+;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
+;;; Returns the list of specified parameters names in the
+;;; order they appeared in the call. N-POSITIONAL is the
+;;; number of positional arguments in th call.
+(defun eliminate-keyword-args (call n-positional specs)
+  (let* ((specs (copy-tree specs))
+         (all (combination-args call))
+         (new-args (reverse (subseq all 0 n-positional)))
+         (key-args (subseq all n-positional))
+         (parameters nil))
+    (loop while key-args
+          do (let* ((key (pop key-args))
+                    (val (pop key-args))
+                    (keyword (if (constant-lvar-p key)
+                                 (lvar-value key)
+                                 (give-up-ir1-transform)))
+                    (spec (or (assoc keyword specs :test #'eq)
+                              (give-up-ir1-transform))))
+               (push val new-args)
+               (flush-dest key)
+               (push (second spec) parameters)
+               ;; In case of duplicate keys.
+               (setf (second spec) (gensym))))
+    (setf (combination-args call) (reverse new-args))
+    (reverse parameters)))
 
 (defun extract-fun-args (lvar fun num-args)
   (declare (type lvar lvar)
@@ -2040,3 +2074,12 @@
                 (eq (global-var-kind leaf) :global-function)
                 (not (null (member (leaf-source-name leaf) names
                                    :test #'equal))))))))
+
+(defun lvar-matches (lvar &key fun-names arg-count)
+  (let ((use (lvar-use lvar)))
+    (and (combination-p use)
+         (or (not fun-names)
+             (member (combination-fun-source-name use)
+                     fun-names :test #'eq))
+         (or (not arg-count)
+             (= arg-count (length (combination-args use)))))))

Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.95
retrieving revision 1.96
diff -u -d -r1.95 -r1.96
--- locall.lisp	6 May 2009 15:50:19 -0000	1.95
+++ locall.lisp	16 May 2009 12:23:14 -0000	1.96
@@ -99,6 +99,37 @@
                       (setf (lvar-dynamic-extent (cdr cell)) cleanup)))))
   (values))
 
+;;; Called after a transform has been applied to CALL: if the call has a DX
+;;; result, propagate the DXness to the new functional as well.
+;;;
+;;; This is needed in case an earlier call to LOCALL-ANALYZE-COMPONENT
+;;; collected DX information before the transformation, in which case a later
+;;; call to LOCALL-ANALYZE-COMPONENT would not pick up the DX declaration
+;;; again, since the call has already been converted. (In other words, work
+;;; around the fact that optimization iterates, and locall analysis may have
+;;; already run by the time we are able to transform something.)
+(defun maybe-propagate-dynamic-extent (call fun)
+  (when (lambda-p fun)
+    (let* ((lvar (combination-lvar call))
+           (cleanup (or (and lvar (lvar-dynamic-extent lvar))
+                        (return-from maybe-propagate-dynamic-extent)))
+           (ret (lambda-return fun))
+           (res (if ret
+                    (return-result ret)
+                    (return-from maybe-propagate-dynamic-extent)))
+           (dx (car (rassoc lvar (cleanup-info cleanup) :test #'eq)))
+           (new-dx-lvars (if (and dx res)
+                             (handle-nested-dynamic-extent-lvars dx res)
+                             (return-from maybe-propagate-dynamic-extent))))
+      (when new-dx-lvars
+        ;; This builds on what RECOGNIZE-DYNAMIC-EXTENT-LVARS does above.
+        (aver (eq call (block-last (node-block call))))
+        (dolist (cell new-dx-lvars)
+          (let ((lvar (cdr cell)))
+            (aver (not (lvar-dynamic-extent lvar)))
+            (push cell (cleanup-info cleanup))
+            (setf (lvar-dynamic-extent (cdr cell)) cleanup)))))))
+
 ;;; 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