;;;; files for more information.
(in-package "SB!C")
-
-(file-comment
- "$Header$")
\f
;;;; mapping onto lists: the MAPFOO functions
\f
;;;; mapping onto sequences: the MAP function
-;;; Try to compile MAP efficiently when we can determine sequence
+;;; MAP is %MAP plus a check to make sure that any length specified in
+;;; the result type matches the actual result. We also wrap it in a
+;;; TRULY-THE for the most specific type we can determine.
+(deftransform map ((result-type-arg fun &rest seqs) * * :node node)
+ (let* ((seq-names (make-gensym-list (length seqs)))
+ (bare `(%map result-type-arg fun ,@seq-names))
+ (constant-result-type-arg-p (constant-continuation-p result-type-arg))
+ ;; what we know about the type of the result. (Note that the
+ ;; "result type" argument is not necessarily the type of the
+ ;; result, since NIL means the result has NULL type.)
+ (result-type (if (not constant-result-type-arg-p)
+ 'consed-sequence
+ (let ((result-type-arg-value
+ (continuation-value result-type-arg)))
+ (if (null result-type-arg-value)
+ 'null
+ result-type-arg-value)))))
+ `(lambda (result-type-arg fun ,@seq-names)
+ (truly-the ,result-type
+ ,(cond ((policy node (> speed safety))
+ bare)
+ ((not constant-result-type-arg-p)
+ `(sequence-of-checked-length-given-type ,bare
+ result-type-arg))
+ (t
+ (let ((result-ctype (specifier-type result-type)))
+ (if (array-type-p result-ctype)
+ (let* ((dims (array-type-dimensions result-ctype))
+ (dim (first dims)))
+ (if (eq dim '*)
+ bare
+ `(vector-of-checked-length-given-length ,bare
+ ,dim)))
+ bare))))))))
+
+;;; Try to compile %MAP efficiently when we can determine sequence
;;; argument types at compile time.
;;;
;;; Note: This transform was written to allow open coding of
;;; handle that case more efficiently, but it's left as an exercise to
;;; the reader, because the code is complicated enough already and I
;;; don't happen to need that functionality right now. -- WHN 20000410
-;;;
-;;; FIXME: Now that we have this transform, we should be able
-;;; to get rid of the macros MAP-TO-LIST, MAP-TO-SIMPLE,
-;;; and MAP-FOR-EFFECT.
-(deftransform map ((result-type fun &rest seqs) * *)
+(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space))
"open code"
(unless seqs (abort-ir1-transform "no sequence args"))
(unless (constant-continuation-p result-type)
(t (give-up-ir1-transform
"internal error: unexpected sequence type"))))
(t
- (let* ((seq-args (mapcar (lambda (seq)
- (declare (ignore seq))
- (gensym "SEQ"))
- seqs))
+ (let* ((seq-args (make-gensym-list (length seqs)))
(index-bindingoids
(mapcar (lambda (seq-arg seq-supertype)
(let ((i (gensym "I")))
;; of the &REST vars.)
`(lambda (result-type fun ,@seq-args)
(declare (ignore result-type))
- (do ((really-fun (if (functionp fun)
- fun
- (%coerce-name-to-function fun)))
+ (do ((really-fun (%coerce-callable-to-function fun))
,@index-bindingoids
(acc nil))
((or ,@tests)
`(if (funcall test e ',(car els))
',els
,(frob (cdr els)))
- 'nil)))
+ nil)))
(frob val)))))
;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER
(cond (test
(unless (continuation-function-is test '(eq))
(give-up-ir1-transform)))
- ((types-intersect (continuation-type item)
- (specifier-type 'number))
+ ((types-equal-or-intersect (continuation-type item)
+ (specifier-type 'number))
(give-up-ir1-transform "Item might be a number.")))
`(,eq-fun item list))))
(T (setq splice x)))))
(deftransform fill ((seq item &key (start 0) (end (length seq)))
- (simple-array t &key (:start t) (:end index)))
- "open code"
- '(do ((i start (1+ i)))
- ((= i end) seq)
- (declare (type index i))
- (setf (aref seq i) item)))
-
-(deftransform position ((item list &key (test #'eql)) (t list))
+ (vector t &key (:start t) (:end index))
+ *
+ :policy (> speed space))
"open code"
- '(do ((i 0 (1+ i))
- (l list (cdr l)))
- ((endp l) nil)
- (declare (type index i))
- (when (funcall test item (car l)) (return i))))
-
-(deftransform position ((item vec &key (test #'eql) (start 0)
- (end (length vec)))
- (t simple-array &key (:start t) (:end index)))
- "open code"
- '(do ((i start (1+ i)))
- ((= i end) nil)
- (declare (type index i))
- (when (funcall test item (aref vec i)) (return i))))
-
-;;; names of predicates that compute the same value as CHAR= when
-;;; applied to characters
-(defconstant char=-functions '(eql equal char=))
-
-(deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2
- test)
- (simple-string simple-string &rest t))
- (unless (or (not test)
- (continuation-function-is test char=-functions))
- (give-up-ir1-transform))
- '(sb!impl::%sp-string-search string1 start1 (or end1 (length string1))
- string2 start2 (or end2 (length string2))))
-
-(deftransform position ((item sequence &key from-end test (start 0) end)
- (t simple-string &rest t))
- (unless (or (not test)
- (continuation-function-is test char=-functions))
- (give-up-ir1-transform))
- `(and (typep item 'character)
- (,(if (constant-value-or-lose from-end)
- 'sb!impl::%sp-reverse-find-character
- 'sb!impl::%sp-find-character)
- sequence start (or end (length sequence))
- item)))
-
-(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end)
- (t simple-string &rest t))
- `(if (position item sequence
- ,@(when from-end `(:from-end from-end))
- :test test :start start :end end)
- item
- nil))
+ (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
+ `(with-array-data ((data seq)
+ (start start)
+ (end end))
+ (declare (type (simple-array ,element-type 1) data))
+ (do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ ;; WITH-ARRAY-DATA did our range checks once and for all, so
+ ;; it'd be wasteful to check again on every AREF.
+ (declare (optimize (safety 0)))
+ (setf (aref data i) item)))))
\f
;;;; utilities
-;;; Return true if Cont's only use is a non-notinline reference to a global
-;;; function with one of the specified Names.
+;;; Return true if CONT's only use is a non-notinline reference to a
+;;; global function with one of the specified NAMES.
(defun continuation-function-is (cont names)
(declare (type continuation cont) (list names))
(let ((use (continuation-use cont)))
(eq (global-var-kind leaf) :global-function)
(not (null (member (leaf-name leaf) names :test #'equal))))))))
-;;; If Cont is a constant continuation, the return the constant value. If
-;;; it is null, then return default, otherwise quietly GIVE-UP.
+;;; If CONT is a constant continuation, the return the constant value.
+;;; If it is null, then return default, otherwise quietly give up the
+;;; IR1 transform.
+;;;
;;; ### Probably should take an ARG and flame using the NAME.
(defun constant-value-or-lose (cont &optional default)
(declare (type (or continuation null) cont))
(give-up-ir1-transform))))
#|
-;;; This is a frob whose job it is to make it easier to pass around the
-;;; arguments to IR1 transforms. It bundles together the name of the argument
-;;; (which should be referenced in any expansion), and the continuation for
-;;; that argument (or NIL if unsupplied.)
-(defstruct (arg (:constructor %make-arg (name cont)))
+;;; This is a frob whose job it is to make it easier to pass around
+;;; the arguments to IR1 transforms. It bundles together the name of
+;;; the argument (which should be referenced in any expansion), and
+;;; the continuation for that argument (or NIL if unsupplied.)
+(defstruct (arg (:constructor %make-arg (name cont))
+ (:copier nil))
(name nil :type symbol)
(cont nil :type (or continuation null)))
(defmacro make-arg (name)
(eql (continuation-value cont) x)))
(eql default x)))
-(defstruct iterator
+(defstruct (iterator (:copier nil))
;; The kind of iterator.
(kind nil (member :normal :result))
;; A list of LET* bindings to create the initial state.
,body))
((not (csubtypep (continuation-type fun-cont)
(specifier-type 'function)))
- (when (policy *compiler-error-context* (> speed brevity))
+ (when (policy *compiler-error-context*
+ (> speed inhibit-warnings))
(compiler-note
"~S may not be a function, so must coerce at run-time."
n-fun))
(- start2 start1))))))
index)
(t nil))
- ,(if equalp 'end1 'nil))))))
+ ,(if equalp 'end1 nil))))))
(dolist (stuff '((string=* not)
(string/=* identity)))
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
string2 start2 (or end2 (length string2)))))))
+\f
+;;;; string-only transforms for sequence functions
+;;;;
+;;;; Note: CMU CL had more of these, including transforms for
+;;;; functions which cons. In SBCL, we've gotten rid of most of the
+;;;; transforms for functions which cons, since our GC overhead is
+;;;; sufficiently large that it doesn't seem worth it to try to
+;;;; economize on function call overhead or on the overhead of runtime
+;;;; type dispatch in AREF. The exception is CONCATENATE, since
+;;;; a full call to CONCATENATE would have to look up the sequence
+;;;; type, which can be really slow.
+;;;;
+;;;; FIXME: It would be nicer for these transforms to work for any
+;;;; calls when all arguments are vectors with the same element type,
+;;;; rather than restricting them to STRINGs only.
+
+;;; FIXME: Shouldn't we be testing for legality of
+;;; * START1, START2, END1, and END2 indices?
+;;; * size of copied string relative to destination string?
+;;; (Either there should be tests conditional on SAFETY>=SPEED, or
+;;; the transform should be conditional on SPEED>SAFETY.)
+;;;
+;;; FIXME: Also, the transform should probably be dependent on
+;;; SPEED>SPACE.
+(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
+ end1 end2)
+ (simple-string simple-string &rest t))
+ `(locally
+ (declare (optimize (safety 0)))
+ (bit-bash-copy string2
+ (the index
+ (+ (the index (* start2 sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ string1
+ (the index
+ (+ (the index (* start1 sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ (the index
+ (* (min (the index (- (or end1 (length string1))
+ start1))
+ (the index (- (or end2 (length string2))
+ start2)))
+ sb!vm:byte-bits)))
+ string1))
+
+;;; FIXME: It seems as though it should be possible to make a DEFUN
+;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
+;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
+;;; at least once DYNAMIC-EXTENT works.
+(deftransform concatenate ((rtype &rest sequences)
+ (t &rest simple-string)
+ simple-string)
+ (collect ((lets)
+ (forms)
+ (all-lengths)
+ (args))
+ (dolist (seq sequences)
+ (declare (ignore seq))
+ (let ((n-seq (gensym))
+ (n-length (gensym)))
+ (args n-seq)
+ (lets `(,n-length (the index (* (length ,n-seq) sb!vm:byte-bits))))
+ (all-lengths n-length)
+ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res start
+ ,n-length))
+ (forms `(setq start (+ start ,n-length)))))
+ `(lambda (rtype ,@(args))
+ (declare (ignore rtype))
+ (let* (,@(lets)
+ (res (make-string (truncate (the index (+ ,@(all-lengths)))
+ sb!vm:byte-bits)))
+ (start ,vector-data-bit-offset))
+ (declare (type index start ,@(all-lengths)))
+ ,@(forms)
+ res))))
+\f
+;;;; CONS accessor DERIVE-TYPE optimizers
+
+(defoptimizer (car derive-type) ((cons))
+ (let ((type (continuation-type cons))
+ (null-type (specifier-type 'null)))
+ (cond ((eq type null-type)
+ null-type)
+ ((cons-type-p type)
+ (cons-type-car-type type)))))
+
+(defoptimizer (cdr derive-type) ((cons))
+ (let ((type (continuation-type cons))
+ (null-type (specifier-type 'null)))
+ (cond ((eq type null-type)
+ null-type)
+ ((cons-type-p type)
+ (cons-type-cdr-type type)))))
+\f
+;;;; FIND, POSITION, and their -IF and -IF-NOT variants
+
+;;; We want to make sure that %FIND-POSITION is inline-expanded into
+;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
+;;; expansion, so we factor out the condition into this function.
+(defun check-inlineability-of-find-position-if (sequence from-end)
+ (let ((ctype (continuation-type sequence)))
+ (cond ((csubtypep ctype (specifier-type 'vector))
+ ;; It's not worth trying to inline vector code unless we
+ ;; know a fair amount about it at compile time.
+ (upgraded-element-type-specifier-or-give-up sequence)
+ (unless (constant-continuation-p from-end)
+ (give-up-ir1-transform
+ "FROM-END argument value not known at compile time")))
+ ((csubtypep ctype (specifier-type 'list))
+ ;; Inlining on lists is generally worthwhile.
+ )
+ (t
+ (give-up-ir1-transform
+ "sequence type not known at compile time")))))
+
+;;; %FIND-POSITION-IF for LIST data
+(deftransform %find-position-if ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ '(let ((index 0)
+ (find nil)
+ (position nil))
+ (declare (type index index))
+ (dolist (i sequence (values find position))
+ (let ((key-i (funcall key i)))
+ (when (and end (>= index end))
+ (return (values find position)))
+ (when (>= index start)
+ (when (funcall predicate key-i)
+ ;; This hack of dealing with non-NIL FROM-END for list data
+ ;; by iterating forward through the list and keeping track of
+ ;; the last time we found a match might be more screwy than
+ ;; what the user expects, but it seems to be allowed by the
+ ;; ANSI standard. (And if the user is screwy enough to ask
+ ;; for FROM-END behavior on list data, turnabout is fair play.)
+ ;;
+ ;; It's also not enormously efficient, calling PREDICATE and
+ ;; KEY more often than necessary; but all the alternatives
+ ;; seem to have their own efficiency problems.
+ (if from-end
+ (setf find i
+ position index)
+ (return (values i index))))))
+ (incf index))))
+
+;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
+;;; without loss of efficiency. (I.e., the optimizer should be able
+;;; to straighten everything out.)
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t list t t t t t)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ '(%find-position-if (let ((test-fun (%coerce-callable-to-function test)))
+ (lambda (i)
+ (funcall test-fun i item)))
+ sequence
+ from-end
+ start
+ end
+ (%coerce-callable-to-function key)))
+
+;;; The inline expansions for the VECTOR case are saved as macros so
+;;; that we can share them between the DEFTRANSFORMs and the default
+;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
+;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
+(defun %find-position-or-find-position-if-vector-expansion (sequence-arg
+ from-end
+ start
+ end-arg
+ element
+ done-p-expr)
+ (let ((offset (gensym "OFFSET"))
+ (block (gensym "BLOCK"))
+ (index (gensym "INDEX"))
+ (n-sequence (gensym "N-SEQUENCE-"))
+ (sequence (gensym "SEQUENCE"))
+ (n-end (gensym "N-END-"))
+ (end (gensym "END-")))
+ `(let ((,n-sequence ,sequence-arg)
+ (,n-end ,end-arg))
+ (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
+ (,start ,start)
+ (,end (or ,n-end (length ,n-sequence))))
+ (block ,block
+ (macrolet ((maybe-return ()
+ '(let ((,element (aref ,sequence ,index)))
+ (when ,done-p-expr
+ (return-from ,block
+ (values ,element
+ (- ,index ,offset)))))))
+ (if ,from-end
+ (loop for ,index
+ ;; (If we aren't fastidious about declaring that
+ ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
+ ;; can send us off into never-never land, since
+ ;; INDEX is initialized to -1.)
+ of-type index-or-minus-1
+ from (1- ,end) downto ,start do
+ (maybe-return))
+ (loop for ,index of-type index from ,start below ,end do
+ (maybe-return))))
+ (values nil nil))))))
+
+(def!macro %find-position-vector-macro (item sequence
+ from-end start end key test)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(funcall ,test ,item (funcall ,key ,element)))))
+
+(def!macro %find-position-if-vector-macro (predicate sequence
+ from-end start end key)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(funcall ,predicate (funcall ,key ,element)))))
+
+;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
+(deftransform %find-position-if ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-vector-macro predicate sequence
+ from-end start end key))
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t vector t t t function function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-vector-macro item sequence
+ from-end start end key test))
projects / sbcl.git / blobdiff