common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

1.0.28.51: better MAKE-ARRAY transforms

Browse source 
* 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.
This commit is contained in:
Nikodemus Siivola 2009-05-16 12:23:13 +00:00
parent 4587c7fe25
commit e840f48179
11 changed files with 434 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
NEWS
View file

@ -25,8 +25,18 @@
* optimization: result of (FILL (MAKE-ARRAY ...) ...) and (REPLACE
(MAKE-ARRAY ...) ...) can be stack allocated if the result of MAKE-ARRAY
form can be.
* optimization: result of call to VECTOR can now be stack allocated.
* optimization: MAKE-ARRAY with :INITIAL-CONTENTS is now vastly faster
as long as the resulting array is one-dimensional and has a known
element type. In particular, :INITIAL-CONTENTS (LIST ...) where the
length of the list matches the known length of the vector does not
allocate the list as an intermediate step. Ditto for VECTOR and simple
backquoted forms.
* optimization: MAKE-ARRAY can now stack allocate in the presence of
:INITIAL-CONTENTS and :INITIAL-ELEMENT as long as the result has a
known element type, and is known to be simple and one dimensional.
* improvement: SBCL now emits a compiler note where stack allocation was
requested but could not be provided.
requested but could not be provided (not in all cases, unfortunately)
* improvement: better MACHINE-VERSION responses. (thanks to Josh Elsasser)
* improvement: pretty-printing loop has been implemented properly. (thanks
to Tobias Rittweiler)

4
OPTIMIZATIONS
View file

@ -209,6 +209,10 @@ enough to eliminate something like ':initial-element 0'. Such an optimization
is valid if the vector is being allocated in the heap, but not if it is being
allocated on the stack. You could remove this optimization, but that makes
the heap-allocated case somewhat slower...)
To do this, extend ALLOCATE-VECTOR with ALLOW-JUNK argument, and when
stack allocating don't zero if it is true -- and probably ALLOW-JUNK iff
the vector is a specialized one (cannot have pointers.)
--------------------------------------------------------------------------------
#28
a. Accessing raw slots in structure instances is more inefficient than

8
doc/manual/efficiency.texinfo
View file

@ -93,14 +93,14 @@ useful. At present, SBCL implements stack allocation for
@code{&rest} lists, when these are declared @code{dynamic-extent}.
@item
@code{cons}, @code{list} and @code{list*}, when the result is bound to
a variable declared @code{dynamic-extent}.
@code{cons}, @code{list}, @code{list*}, and @code{vector} when the
result is bound to a variable declared @code{dynamic-extent}.
@item
simple forms of @code{make-array}, whose result is bound to a variable
declared @code{dynamic-extent}: stack allocation is possible only if
the resulting array is one-dimensional, and the call has no keyword
arguments with the exception of @code{:element-type}.
the resulting array is known to be both simple and one-dimensional,
and has a constant @code{:element-type}.
@strong{Note}: stack space is limited, so allocation of a large vector
may cause stack overflow. For this reason potentially large vectors,

370
src/compiler/array-tran.lisp
View file

@ -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

5
src/compiler/generic/vm-fndb.lisp
View file

@ -88,6 +88,11 @@
(defknown %set-symbol-hash (symbol hash)
t (unsafe))
(defknown initialize-vector ((simple-array * (*)) &rest t)
(simple-array * (*))
(always-translatable)
:result-arg 0)
(defknown vector-fill* (t t t t) vector
(unsafe)
:result-arg 0)

53
src/compiler/generic/vm-ir2tran.lisp
View file

@ -16,13 +16,6 @@
(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx)
t)
(defoptimizer (make-array stack-allocate-result) ((&rest args) node dx)
;; The actual stack allocation decision will be made on the basis of what
;; ALLOCATE-VECTOR, but this is needed so that (FILL (MAKE-ARRAY N) X) and
;; (REPLACE (MAKE-ARRAY (LENGTH V)) V) can potentially stack allocate the
;; new vector.
t)
(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
(let* ((lvar (node-lvar node))
(locs (lvar-result-tns lvar
@ -162,6 +155,52 @@
(emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args)
(move-lvar-result node block locs lvar))))
(defoptimizer (initialize-vector ir2-convert)
((vector &rest initial-contents) node block)
(let* ((vector-ctype (lvar-type vector))
(elt-ctype (if (array-type-p vector-ctype)
(array-type-specialized-element-type vector-ctype)
(bug "Unknow vector type in IR2 conversion for ~S."
'initialize-vector)))
(saetp (find-saetp-by-ctype elt-ctype))
(lvar (node-lvar node))
(locs (lvar-result-tns lvar (list (primitive-type vector-ctype))))
(result (first locs))
(elt-ptype (primitive-type elt-ctype))
(tmp (make-normal-tn elt-ptype)))
(emit-move node block (lvar-tn node block vector) result)
(flet ((compute-setter ()
(macrolet
((frob ()
(let ((*package* (find-package :sb!vm))
(clauses nil))
(map nil (lambda (s)
(when (sb!vm:saetp-specifier s)
(push
`(,(sb!vm:saetp-typecode s)
(lambda (index tn)
#!+(or x86 x86-64)
(vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
(sb!vm:saetp-primitive-type-name s))
node block result index tn 0 tn)
#!-(or x86 x86-64)
(vop ,(symbolicate "DATA-VECTOR-SET/"
(sb!vm:saetp-primitive-type-name s))
node block result index tn tn)))
clauses)))
sb!vm:*specialized-array-element-type-properties*)
`(ecase (sb!vm:saetp-typecode saetp)
,@(nreverse clauses)))))
(frob)))
(tnify (index)
(constant-tn (find-constant index))))
(let ((setter (compute-setter))
(length (length initial-contents)))
(dotimes (i length)
(emit-move node block (lvar-tn node block (pop initial-contents)) tmp)
(funcall setter (tnify i) tmp))))
(move-lvar-result node block locs lvar)))
;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
;;; cut it for symbols, where under certain compilation options
;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather

1
src/compiler/ir1opt.lisp
View file

@ -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))

53
src/compiler/ir1util.lisp
View file

@ -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)))))))

31
src/compiler/locall.lisp
View file

@ -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

52
tests/dynamic-extent.impure.lisp
View file

@ -147,15 +147,51 @@
;;; MAKE-ARRAY
(defun-with-dx make-array-on-stack ()
(defun force-make-array-on-stack (n)
(declare (optimize safety))
(let ((v (make-array (min n 1))))
(declare (sb-int:truly-dynamic-extent v))
(true v)
nil))
(defun-with-dx make-array-on-stack-1 ()
(let ((v (make-array '(42) :element-type 'single-float)))
(declare (dynamic-extent v))
(true v)
nil))
(defun force-make-array-on-stack (n)
(declare (optimize safety))
(let ((v (make-array (min n 1))))
(defun-with-dx make-array-on-stack-2 (n x)
(declare (integer n))
(let ((v (make-array n :initial-contents x)))
(declare (sb-int:truly-dynamic-extent v))
(true v)
nil))
(defun-with-dx make-array-on-stack-3 (x y z)
(let ((v (make-array 3
:element-type 'fixnum :initial-contents (list x y z)
:element-type t :initial-contents x)))
(declare (sb-int:truly-dynamic-extent v))
(true v)
nil))
(defun-with-dx make-array-on-stack-4 ()
(let ((v (make-array 3 :initial-contents '(1 2 3))))
(declare (sb-int:truly-dynamic-extent v))
(true v)
nil))
;;; Unfortunately VECTOR-FILL* conses right now, so this one
;;; doesn't pass yet.
#+nil
(defun-with-dx make-array-on-stack-5 ()
(let ((v (make-array 3 :initial-element 12 :element-type t)))
(declare (sb-int:truly-dynamic-extent v))
(true v)
nil))
(defun-with-dx vector-on-stack (x y)
(let ((v (vector 1 x 2 y 3)))
(declare (sb-int:truly-dynamic-extent v))
(true v)
nil))
@ -483,8 +519,14 @@
(assert-no-consing (test-lvar-subst 11))
(assert-no-consing (dx-value-cell 13))
(assert-no-consing (cons-on-stack 42))
(assert-no-consing (make-array-on-stack))
(assert-no-consing (force-make-array-on-stack 128))
(assert-no-consing (make-array-on-stack-1))
(assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
(assert-no-consing (make-array-on-stack-3 9 8 7))
(assert-no-consing (make-array-on-stack-4))
#+nil
(assert-no-consing (make-array-on-stack-5))
(assert-no-consing (vector-on-stack :x :y))
(assert-no-consing (make-foo1-on-stack 123))
(assert-no-consing (nested-good 42))
(#+raw-instance-init-vops assert-no-consing

2
version.lisp-expr
View file

@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"1.0.28.50"
"1.0.28.51"